Apple II Magazines (PO)/Nibble Volume 07, No. 05 (1986-05)(MicroSPARC)(Side A).zip/Nibble Volume 07, No. 05 (1986-05)(MicroSPARC)(Side A).po/LIBRARIAN.S

Text File | 1996-12-24 | 29KB | 955 lines

          LST ON,NOA,G
                         ;
          REP 32
*                              *
*          LIBRARIAN           *
*        by Ken Manly          *
*                              *
*     Copyright (C)  1986      *
*       MicroSPARC, Inc.       *
*      45 Winthrop Street      *
*      Concord, MA  01742      *
*                              *
          REP 32
*    EDASM.SYSTEM assembler    *
          REP 32
                         ;
HIMEM     EQU $73
IPTR      EQU $EE
DATPTR    EQU $FA
SCTPTR    EQU $FC
PRTPTR    EQU $FE
INPUT     EQU $200
DEFSLT    EQU $BE3C
DEFDRV    EQU $BE3D
VPATH1    EQU $BE6C
GOSYSTEM  EQU $BE70
BADCALL   EQU $BE8B
CRACESS   EQU $BEA3
CRFILID   EQU $BEA4
CRAUXID   EQU $BEA5
CRFKIND   EQU $BEA7
SREFNUM   EQU $BEC7
SUNITNUM  EQU $BEC7
SBUFADR   EQU $BEC8
SMARK     EQU $BEC8
OSYSBUF   EQU $BECE
OREFNUM   EQU $BED0
RWREFNUM  EQU $BED6
RWDATA    EQU $BED7
RWCOUNT   EQU $BED9
CREFNUM   EQU $BEDE
MLI       EQU $BF00
DEVCNT    EQU $BF31
DEVLST    EQU $BF32
MACHID    EQU $BF98
PFIXPTR   EQU $BF9A
KBD       EQU $C000
KBSTRB    EQU $C010
TABV      EQU $FB5B
CLREOP    EQU $FC42
HOME      EQU $FC58
RDKEY     EQU $FD0C
NXTCHAR   EQU $FD75
CROUT     EQU $FD8E
COUT      EQU $FDED
BELL      EQU $FF3A
SETV      EQU $FF58      ;Known $60 to set V bit
                         ;
                         ;ProDOS MLI function call codes
                         ;
RDBLK.C   EQU $80
CREATE.C  EQU $C0
ONLINE.C  EQU $C5
OPEN.C    EQU $C8
WRITE.C   EQU $CB
CLOSE.C   EQU $CC
SETMARK.C EQU $CE
GETMARK.C EQU $CF
SETEOF.C  EQU $D0
GETEOF.C  EQU $D1
                         ;
          MSB ON
          ORG $1000
          REP 32
          JSR HOME
          LDX #BANNER1-BANNER0
          LDY #0         ;Print greeting
BNRLP     LDA BANNER0,Y
          BIT MACHID
          BMI BNROUT     ;On Apple II,
          JSR UPCASE     ; change lower case to upper
BNROUT    JSR COUT
          INY
          DEX
          BNE BNRLP
                         ;
                         ;Top level of LIBRARIAN
                         ;
START     CLC
          LDA HIMEM+1    ;Use system buffer
          STA IBUF       ; for catalog sector
          ADC #2
          STA IBUFTOP    ;Limit for scanning input buffer
          SBC #13
          STA DBUFTOP    ;Limit for data buffer
          LDA #<END+$100 ;Beginning of data buffer
          STA DATPTR+1
          LDA #0
          STA DATPTR
          LDY DEVCNT     ;Number of disk drives
          INY
          STY IDEV       ;Initialize drive selector
GETDSK    JSR SRCEPRMPT  ;Ask for disk
          BCC GO
          BCS WRITEOUT
TRYAGAIN  JSR READERR
          BCS WRITEOUT
GO        LDY #<READMSG
          LDX #>READMSG
          LDA #10
          JSR MESSAGE
          JSR FINDDSK    ;Identify disk
          BCS TRYAGAIN
          LDA #$80
          STA FIRSTBLK   ;Indicate start new catalog
          LDY #<READMSG
          LDX #>READMSG
          LDA #10
          JSR MESSAGE
          BIT DISKID
          BPL CTPS       ;Bit 6 clear for Pascal
          BVS CTPD       ;Bit 7 set for ProDOS
          BVC CTD3       ;Bit 7 clear for DOS 3.3
CTPS      JSR PASCAT     ;Do Pascal disk
          BCS ERROR
          BCC CHKSPACE
CTPD      JSR PROCAT     ;Do ProDOS disk
          BCS ERROR
          BCC CHKSPACE
CTD3      JSR DOSCAT     ;Do DOS disk
          BCS ERROR
CHKSPACE  LDA DATPTR+1
          CMP DBUFTOP
          BCC GETDSK     ;Still room for more
          JSR BELL
WRITEOUT  LDA DATPTR
          BNE WROUT      ;Any data to file?
          LDA DATPTR+1
          CMP #<END+$100
          BEQ ENDITALL   ;No
WROUT     JSR DESTPRMPT
          BCS ENDITALL
          JSR OUTFILE    ;Write file information
          BCS WROUT1
          JMP START      ;Do it again
WROUT1    JSR WRITERR
          JMP WROUT
ENDITALL  LDY #<BYE
          LDX #>BYE
          LDA #14
          JSR MESSAGE
          LDA #$0D
          STA INPUT
          CLC
          RTS
                         ;
                         ;Error handling
                         ;
ERROR     STA ERRCODE    ;Save error code
          LDA #0
          STA CREFNUM
          LDA #CLOSE.C   ;Close all files
          JSR GOSYSTEM
          SEC            ;Indicate error
          LDA ERRCODE    ;Get error code
          BNE ERROR1     ;Error was real
          CLC            ;Error was a fake to
          RTS            ; escape
ERROR1    LDX #>RDERRMSG
          LDY #<RDERRMSG
          JSR PROMPT
          JMP CHKSPACE   ;Back into the program
          REP 32
                         ;
                         ;Subroutine to find a disk
                         ;
DEVLP     LDY DEVCNT     ;Number of disk drives
          INY
          STY IDEV
          BIT KBD
          BPL FINDDSK
          SEC            ;Abort on keystroke
          LDA KBSTRB
          LDA #8         ;Fake error
          BCS DEVRTN
FINDDSK   DEC IDEV
          BPL NXTDEV
          BMI DEVLP
NXTDEV    LDY IDEV       ;Pick a drive from
          LDX DEVLST,Y   ; device list
          TXA
          AND #$0F       ;Look at device ID
          BNE FINDDSK    ;Not a Disk II
          TXA
          AND #$F0       ;Isolate device number
          STA BRWUNIT    ;Save in parm list
          JSR RDIDBLK    ;Try to identify disk
          BCS FINDDSK    ;Not there
DEVRTN    RTS
                         ;
                         ;Subroutine to identify DOS 3.3, ProDOS,
                         ; or PASCAL disks by characteristic bytes
                         ;
RDIDBLK   LDA IBUF
          STA IPTR+1
          LDA #0
          STA IPTR
          LDX #2         ;Read block 2
          JSR READBLK
          BCS RDIDRTN
          LDY #2         ;Examine byte 2
          LDA (IPTR),Y   ;Get ID byte
          LDY #7
IDLP      CMP IDLIST,Y   ;Look for it
          BEQ GETIDBYTE  ; in the list
          DEY            ; of acceptable
          BPL IDLP       ; bytes
          LDA #6         ;Not found, load
          SEC            ; fake volume not found
          BCS RDIDRTN    ; error
GETIDBYTE LDA IDBYTES,Y  ;Found, load and save the
          STA DISKID     ; corresponding code
          CLC            ;If C clear,
RDIDRTN   RTS            ; DISKID is valid
                         ;
                         ;Main subroutine to handle PASCAL directory
                         ;
PASCAT    LDA #2
          STA CURBLK     ;Start with block 2
PASCATLP  LDX CURBLK
          LDA #0
          JSR READBLK
          BCS PASCATRTN
          JSR PASNAMES   ;Transfer names to data buffer
          BCS PASCATRTN
          BVS PASCATRTN  ;V set when finished
          INC CURBLK     ;Next block
          LDA CURBLK
          CMP #6
          BCC PASCATLP
          CLC
PASCATRTN RTS
                         ;
                         ;Main subroutine to handle ProDOS directory
                         ;
PROCAT    LDA #2
          STA CURBLK     ;Start with block 2
PROCATLP  LDX CURBLK
          LDA #0
          JSR READBLK
          BCS PROCATRTN
          JSR PRONAMES   ;Transfer names to data buffer
          BCS PROCATRTN
          BVS PROCATRTN
          INC CURBLK     ;Next block
          LDA CURBLK
          CMP #6
          BCC PROCATLP
          CLC
PROCATRTN RTS
                         ;
                         ;Main subroutine to handle DOS 3.3 catalog
                         ;
DOSCAT    JSR RDVTOC
          BCS DOSCATRTN
DOSCATLP  JSR NXTSECTOR
          BEQ DOSCATFIN
          BCS DOSCATRTN
          JSR DOSNAMES
          BCS DOSCATRTN
          BVC DOSCATLP
DOSCATFIN CLC
DOSCATRTN RTS
                         ;
                         ;Subroutine to read sector chained to current one
                         ;
NXTSECTOR LDA IBUF
          STA BRWDATA+1
          LDY #0
          STY SCTPTR
          INY
          LDA (SCTPTR),Y ;Track number
          BEQ NXTSRTN
          TAX
          INY
          LDA (SCTPTR),Y ;Sector number
          JSR RDTS
          BCC NXTOK
          JSR READERR
          BCC NXTSECTOR
NXTOK     STA SCTPTR+1
NXTSRTN   RTS            ;C set for err; Z set for end
                         ;
                         ;Subroutine to read VTOC
                         ;
RDVTOC    LDA IBUF
          STA BRWDATA+1
          LDX #17        ;Track 17
          LDA #0         ;Sector 0
          JSR RDTS       ;Read it
          STA SCTPTR+1
          RTS
                         ;
                         ;Subroutine to read block indicated by A,X
                         ;
READBLK   STA BRWBLKNUM+1 ;Store desired block
          STX BRWBLKNUM  ; number in parm table
          LDA IBUF       ;Store address of
          STA BRWDATA+1  ; input buffer in
          LDA #0         ; parm table
          STA BRWDATA
          JSR MLI        ;Go get it
          DB RDBLK.C
          DW BRW
          BCS RDBLKRTN
          BIT DISKID
          BVS RDBLKRTN   ;Not Pascal
          INC BRWBLKNUM  ;Put next block
          INC BRWDATA+1  ;In upper half of
          INC BRWDATA+1  ; input buffer
          JSR MLI
          DB RDBLK.C
          DW BRW
RDBLKRTN  RTS
                         ;
                         ;Subroutine to transfer Pascal filename
                         ; to data buffer
                         ;
PASNAMES  BIT FIRSTBLK   ;First entry?
          BPL PACONT     ;No
          LSR FIRSTBLK
          LDA #6
          STA IPTR       ;Points to
          LDA IBUF
          STA IPTR+1     ; volume name (length byte)
          LDY #0
          LDA (IPTR),Y
          JSR GETVNAME
          LDA #24        ;24 bytes to first file entry
          JSR INCIPTR    ;Raise input buffer pointer
PACONT    LDY #0
          LDA (IPTR),Y   ;File type
          STA FTYPE
          LDA #2
          JSR INCIPTR    ;Raise input buffer pointer
          LDA (IPTR),Y   ;Filename length
          STA FNMLNGTH
          BNE PANXT
          BIT SETV       ;End of catalog
          BVS PARTN      ; V set to quit
PANXT     LDX #5
          JSR PUTOSNM    ;Transfer system name
          JSR PUTVNAME   ;Transfer volume name
          JSR TXFNAME    ;Transfer file name
          LDA FTYPE
          ASL
          ASL
          CLC
          ADC #4
          TAX
          LDA #4
          JSR PUTTYPE    ;Transfer file type
          LDA #24        ;24 more bytes per file entry
          JSR INCIPTR    ;Raise input buffer pointer
          BCC PACONT
          LDA IBUF       ;Reset pointer hi byte
          STA IPTR+1     ; (leave low byte intact)
PARTN     CLC
          RTS
                         ;
                         ;Subroutine to transfer ProDOS filename
                         ; to data buffer
                         ;
PRONAMES  BIT FIRSTBLK   ;First entry?
          BPL PRCONT     ;No
          LSR FIRSTBLK
          LDA #4
          STA IPTR       ;Points to
          LDA IBUF
          STA IPTR+1     ; volume name (length byte)
          LDY #0
          LDA (IPTR),Y
          AND #$0F       ;Isolate volume name length
          JSR GETVNAME
          LDA #39
          JSR INCIPTR    ;Raise input buffer pointer
PRCONT    LDY #0         ;Get length
          LDA (IPTR),Y   ; of filename
          BEQ PRCHKEND   ;Deleted file or end of cat
          AND #$0F       ;Isolate file name length
          STA FNMLNGTH
          LDY #$10
          LDA (IPTR),Y   ;File type
          LDY #12
PRTYPLP   DEY
          BEQ PRSTTYP
          CMP PRCODES,Y
          BNE PRTYPLP
PRSTTYP   STY FTYPE
          LDX #11
          JSR PUTOSNM    ;Transfer system name
          JSR PUTVNAME   ;Transfer volume name
          JSR TXFNAME    ;Transfer file name
          LDA FTYPE
          ASL
          CLC
          ADC FTYPE
          ADC #PRTYPES-TYPES+3
          TAX
          LDA #3
          JSR PUTTYPE    ;Transfer file type
          JMP PRNXT
PRCHKEND  INY
          LDA (IPTR),Y   ;Check first letter of filename
          BNE PRNXT      ;Deleted file; try next
          BIT SETV       ;File never was; end of catalog
          BVS PRRTN
PRNXT     LDA #39        ;39 bytes per file entry
          JSR INCIPTR    ;Raise input buffer pointer
          BCC PRCONT
          LDA IBUF       ;Reset pointer hi byte
          STA IPTR+1
          LDA #4         ; and pointer low byte
          STA IPTR
          CLV            ;Keep going
PRRTN     CLC
          RTS
                         ;
                         ;Subroutine to transfer DOS3.3 filename
                         ; to data buffer
                         ; Enter with hi byte of sector buffer in A
                         ;
DOSNAMES  STA IPTR+1     ;Pick right half of block
          LDA #11        ;Points to track
          STA IPTR       ; byte ($FF if deleted)
          BIT FIRSTBLK   ;First entry?
          BPL DSSCTLP    ;No
          LSR FIRSTBLK
          LDY #<NAMEMSG
          LDX #>NAMEMSG
          LDA #10
          JSR MESSAGE    ;Ask for disk name
          JSR CROUT
          JSR NXTCHAR    ;Accept name
          STX VOLNAME
DSNMLP    LDA INPUT-1,X
          AND #$7F
          STA VOLNAME,X
          DEX
          BNE DSNMLP
DSSCTLP   LDY #0
          LDA (IPTR),Y   ;Check track ($FF if deleted)
          BEQ DSDONE     ;End of catalog
          CMP #$FF
          BNE DSGOOD
          LDA #35        ;Skip deleted file
          BNE DSDLTD
DSGOOD    INC IPTR
          INC IPTR
          LDA (IPTR),Y   ;Y is still 0
          AND #$7F
          BEQ DSSTTYP
DSTYPLP   INY
          LSR
          BCC DSTYPLP
          TYA
DSSTTYP   STA FTYPE
          LDX #17
          JSR PUTOSNM    ;Transfer system name
          JSR PUTVNAME   ;Transfer volume name
          LDY #31
          LDA #$A0       ;Space
TRSPLP    DEY            ;Skip trailing spaces
          CMP (IPTR),Y
          BEQ TRSPLP
          STY FNMLNGTH
          JSR TXFNAME    ;Transfer file name
          CLC
          LDA FTYPE
          ADC #DOSTYPES-TYPES+1
          TAX
          LDA #1
          JSR PUTTYPE    ;Transfer file type
          LDA #33        ;35 bytes per file entry
DSDLTD    JSR INCIPTR    ;Raise input buffer pointer
          CMP SCTPTR+1
          BEQ DSSCTLP    ;Still more in this sector
          CLV            ;Ask for another sector
          CLC            ;No error yet
          RTS
DSDONE    CLC
          BIT SETV
          RTS
                         ;
                         ;Set up volume name
                         ;Enter with length in A
                         ;
GETVNAME  TAY
          STA VOLNAME
GVNMLP    LDA (IPTR),Y
          STA VOLNAME,Y
          DEY
          BNE GVNMLP
          RTS
                         ;
                         ;Transfer system name
                         ;
PUTOSNM   LDY #6
          LDA #$0D       ;Put <RETURN>
POSNMLP   STA (DATPTR),Y ; at end
          LDA OSNAMES,X  ;Read system name
          DEX            ; out of table
          DEY
          BPL POSNMLP
          LDA #6
          JSR INCDPTR    ;Raise data pointer
          RTS
                         ;
                         ;Transfer volume name
                         ;
PUTVNAME  LDA #$0D
          LDY VOLNAME    ;Put <RETURN>
          STA (DATPTR),Y ; at end
          BEQ NULLNAME   ;No name
PVNMLP    LDA VOLNAME,Y
          DEY
          STA (DATPTR),Y
          BNE PVNMLP
NULLNAME  LDA VOLNAME
          JSR INCDPTR    ;Raise data pointer
          RTS
                         ;
                         ;Transfer filename
                         ;Enter with namelength in Y
                         ;
          MSB OFF
TXFNAME   LDY FNMLNGTH
          LDA #$0D       ;Put <RETURN>
          STA (DATPTR),Y ; at end
TXFNLP    LDA (IPTR),Y
          ORA #$80       ;to make UPCASE work
          CMP #$A0       ;Space
          BCS NOTCNTRL
          LDA #'^'       ;Substitute cntrl chars
NOTCNTRL  JSR UPCASE
          AND #$7F       ;ProDOS keeps bit 7 clear
          DEY
          STA (DATPTR),Y
          BNE TXFNLP
          LDA FNMLNGTH
          JSR INCDPTR    ;Raise data pointer
          RTS
                         ;
                         ;Transfer file type
                         ;
PUTTYPE   PHA
          TAY
          LDA #$0D       ;Put <RETURN>
          STA (DATPTR),Y ; at end
PTLP      DEX
          DEY
          BMI PTXT
          LDA TYPES,X
          STA (DATPTR),Y
          BNE PTLP
PTXT      PLA
          JSR INCDPTR    ;Raise data pointer
          RTS
                         ;
                         ;Increase DATPTR by one more than
                         ; the value in A
                         ;
INCDPTR   SEC
          ADC DATPTR
          STA DATPTR
          LDA DATPTR+1
          ADC #0
          STA DATPTR+1
          RTS
                         ;
                         ;Increase IPTR by the value in A
                         ; and compare IPTR to buffer limit
                         ;
INCIPTR   CLC
          ADC IPTR
          STA IPTR
          LDA IPTR+1
          ADC #0
          STA IPTR+1
          CMP IBUFTOP
          RTS
                         ;
                         ;Subroutine to read given track and sector
                         ; On entry, track in X, sector in A
                         ; Calling routine must set up BRWUNIT and point
                         ;  BRWDATA to base of 512-byte buffer
                         ; On exit, A will point to the
                         ;  appropriate half of the data buffer
                         ;
RDTS      TAY
          TXA
          LDX #0
          STX BRWBLKNUM+1
          ASL            ;Block number
          ASL            ; is 8 times
          ASL            ; track number plus
          ROL BRWBLKNUM+1 ; offset defined by
          CLC            ; sector number
          ADC OFFSET,Y
          STA BRWBLKNUM
          CLC
          LDA HALFTABLE,Y ;Only one half of
          ADC BRWDATA+1  ; block will have
          STA SECTOR     ; relevant data
          JSR MLI
          DB RDBLK.C
          DW BRW
          BCC RDOK
          JMP BADCALL    ;Return by way of BADCALL
RDOK      LDA SECTOR
          RTS
                         ;
                         ;Prompting subroutine allows retry for I/O error
                         ; or PATH NOT FOUND -- returns C clear for <return>
                         ; or <space>, C set and A=0 for <esc>, C set and
                         ; A=error for other errors
                         ;
SRCEPRMPT LDX #>SRCEMSG
          LDY #<SRCEMSG
          BNE PROMPT     ;Always
DESTPRMPT LDX #>DESTMSG
          LDY #<DESTMSG
          BNE PROMPT     ;Always
READERR   STA ERRCODE    ;Save error code
          JSR CLOSE      ;Try to close files
          LDA ERRCODE
          CMP #6         ;Prompt if error is 6,7 or 8
          BCC ERRRTN     ; (Path not found
          CMP #9         ; or I/O error)
          BCS ERRRTN     ;Return with some other error
          LDX #>RDERRMSG
          LDY #<RDERRMSG
          BNE PROMPT     ;Always
WRITERR   STA ERRCODE    ;Save error code
          JSR CLOSE      ;Try to close files
          LDA ERRCODE
          CMP #4         ;Write-protected
          BNE WRER1
          LDX #>WRPRTMSG
          LDY #<WRPRTMSG
          BNE PROMPT     ;Always
WRER1     CMP #9         ;Disk full
          BEQ WRER2
          CMP #$11       ;Directory full
          BNE WRER3
WRER2     LDX #>FULLMSG
          LDY #<FULLMSG
          BNE PROMPT     ;Always
WRER3     LDX #>WRERRMSG ;Misc write error
          LDY #<WRERRMSG
PROMPT    LDA #10
          JSR MESSAGE
PROMPT1   LDY #<ACTIONREQ
          LDX #>ACTIONREQ
          LDA #11
          JSR MESSAGE    ;Display prompt
KEY       JSR RDKEY      ;Wait for a keystroke
          TAX            ;Save keystroke
          JSR CROUT
          CPX #$8D       ;<RETURN>
          BEQ RETRY      ;Clear C to try again
          CPX #$A0       ;<SPACE>
          BEQ RETRY      ;Clear C to try again
          LDA #0         ;Code for no error
          CPX #$9B       ;<ESC>
          BEQ ERRRTN     ;False error to get out
          BNE PROMPT1
ERRRTN    SEC            ;C set means error
          RTS
RETRY     CLC
          RTS
                         ;
                         ;Subroutine to print message or prompt
                         ;
MESSAGE   STX PRTPTR     ;Point to
          STY PRTPTR+1   ; appropriate message
          JSR TABV       ;Vertical tab
          JSR CROUT      ;Start new line
          JSR CLREOP
          LDY #0
          LDA (PRTPTR),Y ;Get length of message
          TAX            ;Use X as counter
PRTLP     INY            ; and Y as pointer
          LDA (PRTPTR),Y
          BIT MACHID
          BMI PRTOUT     ;On Apple II, change
          JSR UPCASE     ; lower case to upper
PRTOUT    JSR COUT       ;Print a char
          DEX            ;Count down
          BNE PRTLP      ; until done
          RTS
                         ;
                         ;Subsubroutine to convert lower case
                         ;
          MSB ON
UPCASE    CMP #'a'
          BCC UCRTN
          CMP #'{'
          BCS UCRTN
          AND #$DF
UCRTN     RTS
                         ;
                         ;Subroutine to write accumulated directories
                         ; to file
                         ;
OUTFILE   EQU *
          JSR PREFIX     ;Get prefix and filename
          BCS OFRTN1
                         ;Create a TCAT file--complain if it already exists
          LDA #$C3       ;Full access
          STA CRACESS
          LDA #4         ;Text
          STA CRFILID
          LDA #0
          STA CRAUXID
          STA CRAUXID+1
          LDA #1         ;Seedling file
          STA CRFKIND
          LDA #CREATE.C
          JSR GOSYSTEM
          BCC OFOPEN
          CMP #$13       ;Duplicate filename
          BEQ APPNDQ     ;File already exists
          SEC
OFRTN1    RTS            ;Real error
                         ;Append or replace an existing TCAT file
APPNDQ    LDY #<APPNDMSG ;File already exists
          LDX #>APPNDMSG ; notify user and
          LDA #10        ; ask whether to
          JSR MESSAGE    ; append or replace
          LDY #<APPNDREQ
          LDX #>APPNDREQ
          LDA #11
          JSR MESSAGE
          JSR KEY        ;Get answer
          ROR APPNDFLG   ; and save it
                         ;Open TCAT
OFOPEN    LDY #<WRITEMSG
          LDX #>WRITEMSG
          LDA #10
          JSR MESSAGE
          JSR PREFIX     ;Get prefix and filename
          BCS OFRTN1
          LDA IBUF
          STA OSYSBUF+1
          LDA #0
          STA OSYSBUF
          LDA #OPEN.C    ;Open file
          JSR GOSYSTEM
          BCS OFRTN2
                         ;Set up to append, if necessary
          BIT APPNDFLG   ;Do we append?
          BMI OFWRT
          LDA OREFNUM    ;Append info to end
          STA SREFNUM    ; of file
          LDA #GETEOF.C  ; by setting
          JSR GOSYSTEM   ; file mark
          BCS OFRTN2     ; equal to
          LDA #SETMARK.C ; end-of-file
          JSR GOSYSTEM
          BCS OFRTN2
                         ;Write the data
OFWRT     LDA OREFNUM
          STA RWREFNUM
          LDA #<END+$100
          STA RWDATA+1   ;Beginning of
          LDA #0         ; data buffer
          STA RWDATA
          LDA DATPTR     ;Number of bytes
          STA RWCOUNT    ; of data in
          SEC            ; the buffer
          LDA DATPTR+1
          SBC RWDATA+1
          STA RWCOUNT+1
          LDA #WRITE.C
          JSR GOSYSTEM   ;Write it!
          BCS OFRTN2
                         ;Adjust the end-of-file mark
          LDA OREFNUM
          STA SREFNUM
          LDA #GETMARK.C ;Set new
          JSR GOSYSTEM   ; end-of-file
          BCS OFRTN2     ; equal to
          LDA #SETEOF.C  ; file mark
          JSR GOSYSTEM   ; in case new file
          BCS OFRTN2     ; is shorter than old
                         ;Close the file
                         ;Warning--this is also used as an independent subroutine
CLOSE     LDA OREFNUM
          STA CREFNUM
          LDA #CLOSE.C   ;Close up
          JSR GOSYSTEM
OFRTN2    RTS
                         ;
                         ;Subroutine to get prefix and filename
                         ;
          MSB OFF
PREFIX    LDA VPATH1
          STA PRTPTR
          LDA VPATH1+1
          STA PRTPTR+1
          LDA PFIXPTR    ;Is there a prefix?
          BNE HAVEPFX    ;Yes
          LDA OFILENAME+1 ;Full pathname available?
          CMP #'/'
          BNE GETPFX     ;No, get prefix
HAVEPFX   LDY #0         ;If so, set up
          LDA OFILENAME  ; to transfer only filename
          STA (PRTPTR),Y
          TAY
          TAX
          BNE OFNMLP     ;Always
GETPFX    LDA DEFDRV     ;Get volume name
          ASL            ; of current default
          ASL            ; device by getting
          ORA DEFSLT     ; current slot and
          ASL            ; drive number and
          ASL            ; calling OnLine to
          ASL            ; get volume name
          ASL
          STA SUNITNUM
          LDX VPATH1
          INX
          STX SBUFADR
          LDX VPATH1+1
          STX SBUFADR+1
          LDA #ONLINE.C
          JSR GOSYSTEM
          BCS PFXRTN
          LDY #1
          LDA (PRTPTR),Y Isolate prefix length
          AND #$0F       ; from first byte
          ADC #$02       ;Increase name length
          PHA            ; to allow for initial /
          LDA #'/'       ; and trailing /
          STA (PRTPTR),Y ;Add the first /
          PLA            ;Recover prefix length
          TAY
          LDA #'/'
          STA (PRTPTR),Y ;Add trailing /
          TYA
          CLC            ;Add filename length
          ADC OFILENAME
          LDY #0
          STA (PRTPTR),Y ;Store pathname length
          TAY
          LDX OFILENAME  ;Counter for filename length
OFNMLP    LDA OFILENAME,X ;Add filename to end
          STA (PRTPTR),Y ; of prefix
          DEY
          DEX
          BNE OFNMLP
          CLC            ;No error
PFXRTN    RTS
                         ;
                         ;Text, tables of data, and workspace
                         ;
          MSB ON
          REP 32
BANNER0   ASC '           DISK LIBRARIAN PRO'
          DB $8D
          ASC '              by Ken Manly'
          DB $8D
          ASC ' Copyright (C) 1986 by MicroSPARC, Inc.'
          DB $8D,$8D
BANNER1   EQU *
          REP 32
                         ;
                         ;Parameter list for Readblock and Writeblock
                         ;
BRW       DFB 3
BRWUNIT   DFB 0
BRWDATA   DW 0
BRWBLKNUM DW 0
                         ;
                         ;Table to convert DOS sectors to ProDOS blocks
                         ;
OFFSET    DFB 0,7,6,6,5,5,4,4
          DFB 3,3,2,2,1,1,0,7
                         ;
                         ;Table to choose right half of a block
                         ; for a requested sector
                         ;
HALFTABLE DFB 0,0,1,0
          DFB 1,0,1,0
          DFB 1,0,1,0
          DFB 1,0,1,1
                         ;
                         ;Characteristic bytes for each type of disk
                         ; Pascal, ProDOS, DOS master, DOS slave
                         ; Two of each to allow for expansion
                         ;
IDLIST    DB $6,$6,$3,$3,$A9,$A9,$0,$0
                         ;
                         ;Codes to identify type of disk
                         ; Pascal, ProDOS, DOS master, DOS slave
                         ; Two of each to allow for expansion
                         ;
IDBYTES   DB $0,$0,$C0,$C0,$80,$80,$80,$80
                         ;
                         ;Filename for catalog listing
                         ;
          MSB OFF
OFILENAME STR 'TCAT'
          DS 16-*+OFILENAME ;Extra space for filename
                         ;
          MSB ON
SRCEMSG   STR 'Ready to read a disk catalog . . .'
ACTIONREQ STR 'Press <RETURN> to go, <ESC> to quit '
READMSG   STR 'Reading catalog . . .'
NAMEMSG   STR 'Enter a name for this DOS disk . . .'
DESTMSG   STR 'Insert disk for catalog file . . .'
RDERRMSG  STR 'Cannot read a disk, try again . . .'
WRPRTMSG  STR 'Disk is write-protected. . .'
FULLMSG   STR 'Disk full, try another. . .'
WRERRMSG  STR 'Cannot write to disk, try another. . .'
APPNDMSG  STR 'Catalog file already exists . . .'
APPNDREQ  STR '<RETURN> to append, <ESC> to replace '
WRITEMSG  STR 'Writing TCAT file . . .'
BYE       STR 'Goodbye . . .'
                         ;
          MSB OFF
OSNAMES   ASC 'PASCALPRODOSDOS3.3'
                         ;
PRCODES   DFB 0,1,4,6,$F,$19,$1A,$1B,$FC,$FD,$FE,$FF
TYPES     ASC 'VOL BAD CODETEXTINFODATAGRAFFOTO'
PRTYPES   ASC '???BADTXTBINDIRADBAWPASPBASVARRELSYS'
DOSTYPES  ASC 'TIABSRAB'
                         ;
FIRSTBLK  DS 1
DISKID    DS 1
IBUF      DS 1
CURBLK    DS 1
ERRCODE   DS 1
SECTOR    DS 1
IDEV      DS 1
VOLNAME   DS 16
FTYPE     DS 1
IBUFTOP   DS 1
DBUFTOP   DS 1
FNMLNGTH  DS 1
APPNDFLG  DS 1
                         ;
END       EQU *